Visual Basic Graphics Programming (2nd Edition)/Visual Basic Graphics Programming 2nd Edition.iso/OldSrc/CH4/SRC/BINCONT.FRM

Visual Basic Form | 1997-01-03 | 20.0 KB | 629 lines

VERSION 4.00
Begin VB.Form BinContForm
   Caption         =   "Binary Contrast"
   ClientHeight    =   4110
   ClientLeft      =   960
   ClientTop       =   1470
   ClientWidth     =   8010
   Height          =   4800
   Left            =   900
   LinkTopic       =   "Form1"
   ScaleHeight     =   274
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   534
   Top             =   840
   Width           =   8130
   Begin VB.PictureBox HistPict
      AutoRedraw      =   -1  'True
      Height          =   2775
      Left            =   4080
      MousePointer    =   2  'Cross
      ScaleHeight     =   181
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   258
      TabIndex        =   4
      Top             =   0
      Width           =   3930
   End
   Begin VB.PictureBox FromSwin
      Height          =   3855
      Left            =   0
      ScaleHeight     =   253
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   245
      TabIndex        =   2
      Top             =   0
      Width           =   3735
      Begin VB.PictureBox FromPict
         AutoRedraw      =   -1  'True
         AutoSize        =   -1  'True
         Height          =   1905
         Left            =   0
         ScaleHeight     =   123
         ScaleMode       =   3  'Pixel
         ScaleWidth      =   88
         TabIndex        =   3
         Top             =   0
         Width           =   1380
      End
   End
   Begin VB.HScrollBar FromHBar
      Enabled         =   0   'False
      Height          =   255
      Left            =   0
      TabIndex        =   1
      Top             =   3840
      Width           =   3765
   End
   Begin VB.VScrollBar FromVBar
      Enabled         =   0   'False
      Height          =   3855
      Left            =   3720
      TabIndex        =   0
      Top             =   0
      Width           =   255
   End
   Begin MSComDlg.CommonDialog FileDialog
      Left            =   3840
      Top             =   0
      _Version        =   65536
      _ExtentX        =   847
      _ExtentY        =   847
      _StockProps     =   0
      CancelError     =   -1  'True
   End
   Begin VB.Menu mnuFile
      Caption         =   "&File"
      Begin VB.Menu mnuFileLoad
         Caption         =   "&Load..."
         Shortcut        =   ^L
      End
      Begin VB.Menu mnuFileSep2
         Caption         =   "-"
      End
      Begin VB.Menu mnuFileExit
         Caption         =   "E&xit"
      End
   End
Attribute VB_Name = "BinContForm"
Attribute VB_Creatable = False
Attribute VB_Exposed = False
Option Explicit
Dim SysPalSize As Integer
Dim NumStaticColors As Integer
Dim StaticColor1 As Integer
Dim StaticColor2 As Integer
Dim LogPal As Integer
Dim bytes() As Byte
Dim wid As Long
Dim hgt As Long
Dim origpal(0 To 255) As PALETTEENTRY
Dim newpal(0 To 255) As PALETTEENTRY
Dim IndexCounts(0 To 255) As Long
Dim ValueCounts(0 To 255) As Long
Dim MaxBlack As Integer
' ************************************************
' Adjust the colors in the image so all those with
' original brightness greater than max_black are
' white and all others are black.
' ************************************************
Sub SetBinaryContrast(pic As Control, max_black As Integer)
Dim i As Integer
Dim val As Integer
Dim status As Long
    MaxBlack = max_black
    ' Remap the values in the logical palette.
    For i = StaticColor1 + 1 To StaticColor2 - 1
        ' Assumes this is a gray scale image.
        If origpal(i).peRed > max_black Then
            val = 255
        Else
            val = 0
        End If
        With newpal(i)
            .peRed = val
            .peGreen = val
            .peBlue = val
            .peFlags = PC_NOCOLLAPSE
        End With
    Next i
    i = SetPaletteEntries(LogPal, StaticColor1 + 1, StaticColor2 - StaticColor1 - 1, newpal(StaticColor1 + 1))
    i = RealizePalette(pic.hdc)
End Sub
' ************************************************
' Return the index of the nonstatic gray closest
' to the given value (assuming the non-static
' colors are a gray scale created by
' MatchGrayPalette).
' ************************************************
Function NearestNonstaticGray(c As Integer) As Integer
Dim dgray As Single
    If c < 0 Then
        c = 0
    ElseIf c > 255 Then
        c = 255
    End If
    dgray = 255 / (StaticColor2 - StaticColor1 - 2)
    NearestNonstaticGray = c / dgray + StaticColor1 + 1
End Function
' ************************************************
' Count the number of pixels with each palette
' index.
' ************************************************
Sub CountIndexes()
Dim X As Integer
Dim Y As Integer
Dim idx As Integer
    ' Start from scratch.
    For X = 0 To SysPalSize - 1
        IndexCounts(X) = 0
    Next X
    ' Count the indexes.
    For Y = 1 To hgt
        For X = 1 To wid
            idx = bytes(X, Y)
            IndexCounts(idx) = IndexCounts(idx) + 1
        Next X
    Next Y
End Sub
' ************************************************
' Count the brightness values.
' ************************************************
Sub CountValues()
Dim i As Integer
Dim val As Integer
Dim brightval As Integer
Dim darkval As Integer
    ' Start from scratch.
    For i = 0 To SysPalSize - 1
        ValueCounts(i) = 0
    Next i
    ' Add up the values.
    '
    ' For each palette index i, with brightness
    ' val, there are IndexCounts(i) pixels with
    ' that brightness.
    For i = 0 To SysPalSize - 1
        With origpal(i)
            val = (CInt(.peRed) + .peGreen + .peBlue) / 3
        End With
        ValueCounts(val) = ValueCounts(val) + IndexCounts(i)
    Next i
End Sub
' ***********************************************
' Load the indicated file and prepare to work
' with its palette.
' ***********************************************
Sub LoadFromPict(fname As String)
Dim i As Integer
    On Error GoTo LoadFileError
    FromPict.Picture = LoadPicture(fname)
    On Error GoTo 0
    FromHBar.Enabled = False
    FromVBar.Enabled = False
    DoEvents
    MatchGrayPalette FromPict
    FromPict.Move 0, 0
    ResetScrollBars
    ' Make the new and original palettes match.
    For i = 0 To SysPalSize - 1
        newpal(i) = origpal(i)
    Next i
    ' Count the pixels with each palette index.
    CountIndexes
    ' Count the brightness values.
    CountValues
    ' Display the current histogram.
    MaxBlack = -1
    ShowHistogram
    Caption = "Binary Contrast [" & fname & "]"
    Exit Sub
LoadFileError:
    Beep
    MsgBox "Error loading file " & fname & "." & _
        vbCrLf & Error$
    Exit Sub
End Sub
Private Sub Form_Unload(Cancel As Integer)
    End
End Sub
' ************************************************
' Present a message indicating the pixel's palette
' index and color value.
' ************************************************
Private Sub FromPict_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If X > wid Or Y > hgt Then Exit Sub

    With newpal(bytes(X, Y))
        MsgBox "Palette index:" & Str$(bytes(X, Y)) & _
            vbCrLf & "Red:  " & Str$(.peRed) & _
            vbCrLf & "Green:" & Str$(.peGreen) & _
            vbCrLf & "Blue: " & Str$(.peBlue)
    End With
End Sub
' ***********************************************
' Load the control's palette so it matches the
' the system palette. Remap any of the image's
' pixels that use static colors to non-static
' colors.
' Set the following module global variables.
'   LogPal      Image logical palette handle.
'   origpal()  Image logical palette entries.
'   wid         Width of image.
'   hgt         Height of image.
'   bytes(1 To wid, 1 To hgt)
'               Image pixel values.
' ***********************************************
Sub MatchColorPalette(pic As Control)
Dim sys(0 To 255) As PALETTEENTRY
Dim i As Integer
Dim bm As BITMAP
Dim hbm As Integer
Dim status As Long
Dim X As Integer
Dim Y As Integer
Dim clr As Integer
    ' Make sure pic has the foreground palette.
    pic.ZOrder
    i = RealizePalette(pic.hdc)
    DoEvents
    ' Get the system palette entries.
    i = GetSystemPaletteEntries(pic.hdc, 0, SysPalSize, sys(0))

    ' Make the logical palette as big as possible.
    LogPal = pic.Picture.hPal
    If ResizePalette(LogPal, SysPalSize) = 0 Then
        Beep
        MsgBox "Error resizing logical palette.", _
            vbExclamation
        Exit Sub
    End If
    ' Blank the non-static colors.
    For i = 0 To StaticColor1
        origpal(i) = sys(i)
    Next i
    For i = StaticColor1 + 1 To StaticColor2 - 1
        With origpal(i)
            .peRed = 0
            .peGreen = 0
            .peBlue = 0
            .peFlags = PC_NOCOLLAPSE
        End With
    Next i
    For i = StaticColor2 To 255
        origpal(i) = sys(i)
    Next i
    i = SetPaletteEntries(LogPal, 0, SysPalSize, origpal(0))
    ' Insert the non-static colors.
    For i = StaticColor1 + 1 To StaticColor2 - 1
        origpal(i) = sys(i)
        origpal(i).peFlags = PC_NOCOLLAPSE
    Next i
    i = SetPaletteEntries(LogPal, StaticColor1 + 1, StaticColor2 - StaticColor1 - 1, origpal(StaticColor1 + 1))
    ' Realize the new palette.
    i = RealizePalette(pic.hdc)
    ' Get the image pixels.
    hbm = pic.Image
    status = GetObject(hbm, BITMAP_SIZE, bm)
    wid = bm.bmWidthBytes
    hgt = bm.bmHeight
    ReDim bytes(1 To wid, 1 To hgt)
    status = GetBitmapBits(hbm, wid * hgt, bytes(1, 1))
    ' Remap any pixels using static colors.
    For Y = 1 To hgt
        For X = 1 To wid
            clr = bytes(X, Y)
            If clr <= StaticColor1 Or clr >= StaticColor2 Then
                With sys(clr)
                    bytes(X, Y) = _
                        NearestNonstaticColor( _
                        .peRed, .peGreen, .peBlue)
                End With
            End If
        Next X
    Next Y
    ' Update the image's pixel values.
    status = SetBitmapBits(hbm, wid * hgt, bytes(1, 1))
    pic.Refresh
End Sub
' ***********************************************
' Load the control's palette so the non-static
' colors are grays. Map the logical palette to
' match the system palette. Convert the image to
' use the non-static grays.
' Set the following module global variables.
'   LogPal      Image logical palette handle.
'   origpal()  Image logical palette entries.
'   wid         Width of image.
'   hgt         Height of image.
'   bytes(1 To wid, 1 To hgt)
'               Image pixel values.
' ***********************************************
Sub MatchGrayPalette(pic As Control)
Dim sys(0 To 255) As PALETTEENTRY
Dim i As Integer
Dim bm As BITMAP
Dim hbm As Integer
Dim status As Long
Dim X As Integer
Dim Y As Integer
Dim gray As Single
Dim dgray As Single
Dim c As Integer
Dim clr As Integer
    ' Make sure pic has the foreground palette.
    pic.ZOrder
    i = RealizePalette(pic.hdc)
    DoEvents
    ' Get the system palette entries.
    i = GetSystemPaletteEntries(pic.hdc, 0, SysPalSize, sys(0))

    ' Get the image pixels.
    hbm = pic.Image
    status = GetObject(hbm, BITMAP_SIZE, bm)
    wid = bm.bmWidthBytes
    hgt = bm.bmHeight
    ReDim bytes(1 To wid, 1 To hgt)
    status = GetBitmapBits(hbm, wid * hgt, bytes(1, 1))
    ' Make the logical palette as big as possible.
    LogPal = pic.Picture.hPal
    If ResizePalette(LogPal, SysPalSize) = 0 Then
        Beep
        MsgBox "Error resizing logical palette.", _
            vbExclamation
        Exit Sub
    End If
    ' Blank the non-static colors.
    For i = 0 To StaticColor1
        origpal(i) = sys(i)
    Next i
    For i = StaticColor1 + 1 To StaticColor2 - 1
        With origpal(i)
            .peRed = 0
            .peGreen = 0
            .peBlue = 0
            .peFlags = PC_NOCOLLAPSE
        End With
    Next i
    For i = StaticColor2 To 255
        origpal(i) = sys(i)
    Next i
    i = SetPaletteEntries(LogPal, 0, SysPalSize, origpal(0))
    ' Insert the non-static grays.
    gray = 0
    dgray = 255 / (StaticColor2 - StaticColor1 - 2)
    For i = StaticColor1 + 1 To StaticColor2 - 1
        c = gray
        gray = gray + dgray
        With origpal(i)
            .peRed = c
            .peGreen = c
            .peBlue = c
        End With
    Next i
    i = SetPaletteEntries(LogPal, StaticColor1 + 1, StaticColor2 - StaticColor1 - 1, origpal(StaticColor1 + 1))
    ' Recreate the image using the new colors.
    For Y = 1 To hgt
        For X = 1 To wid
            clr = bytes(X, Y)
            With sys(clr)
                c = (CInt(.peRed) + .peGreen + .peBlue) / 3
            End With
            bytes(X, Y) = NearestNonstaticGray(c)
        Next X
    Next Y
    status = SetBitmapBits(hbm, wid * hgt, bytes(1, 1))
    ' Realize the gray palette.
    i = RealizePalette(pic.hdc)
    pic.Refresh
End Sub
' ************************************************
' Return the index of the nonstatic color closest
' to the given color value.
' ************************************************
Function NearestNonstaticColor(ByVal r As Integer, ByVal g As Integer, ByVal b As Integer) As Integer
Dim best_i As Integer
Dim best_dist As Long
Dim dist As Long
Dim dr As Long
Dim dg As Long
Dim db As Long
Dim i As Integer
    best_dist = 1000000
    For i = StaticColor1 + 1 To StaticColor2 - 1
        With origpal(i)
            dr = r - .peRed
            dg = g - .peGreen
            db = b - .peBlue
            dist = dr * dr + dg * dg + db * db
        End With
        If best_dist > dist Then
            best_i = i
            best_dist = dist
        End If
    Next i
    NearestNonstaticColor = best_i
End Function
' ************************************************
' Create a brightness histogram for the image.
' ************************************************
Sub ShowHistogram()
Dim i As Integer
Dim maxy As Single
Dim yscale As Single
    HistPict.Cls
    HistPict.Refresh
    ' **********************
    ' * Display the output *
    ' **********************
    For i = 0 To SysPalSize - 1
        If maxy < ValueCounts(i) Then _
            maxy = ValueCounts(i)
    Next i
    If maxy <> 0 Then
        yscale = -HistPict.ScaleHeight / maxy
    Else
        yscale = 0
    End If
    maxy = HistPict.ScaleTop + HistPict.ScaleHeight
    For i = 0 To SysPalSize - 1
        HistPict.Line (i + 1, maxy)-Step(0, ValueCounts(i) * yscale)
    Next i
    ' Draw a line at the cutoff.
    If MaxBlack >= 0 Then _
        HistPict.Line (MaxBlack + 1, 0)- _
            Step(0, HistPict.ScaleHeight), vbRed
End Sub
' ***********************************************
' Set the Max and LargeChange properties for the
' image scroll bars.
' ***********************************************
Sub ResetScrollBars()
    ' FromHBar.
    FromHBar.Value = 0
    If FromSwin.ScaleWidth >= FromPict.Width Then
        FromHBar.Enabled = False
    Else
        FromHBar.Max = FromPict.Width - FromSwin.ScaleWidth
        FromHBar.LargeChange = FromSwin.ScaleWidth
        FromHBar.Enabled = True
    End If
    ' FromVBar.
    FromVBar.Value = 0
    If FromSwin.ScaleHeight >= FromPict.Height Then
        FromVBar.Enabled = False
    Else
        FromVBar.Max = FromPict.Height - FromSwin.ScaleHeight
        FromVBar.LargeChange = FromSwin.ScaleHeight
        FromVBar.Enabled = True
    End If
End Sub
' ***********************************************
' Give the form and all the picture boxes an
' hourglass cursor.
' ***********************************************
Sub WaitStart()
    MousePointer = vbHourglass
    FromPict.MousePointer = vbHourglass
    HistPict.MousePointer = vbHourglass
    DoEvents
End Sub
' ***********************************************
' Restore the mouse pointers for the form and all
' the picture boxes.
' ***********************************************
Sub WaitEnd()
    MousePointer = vbDefault
    FromPict.MousePointer = vbDefault
    HistPict.MousePointer = vbDefault
End Sub
Private Sub Form_Load()
    ' Make sure the screen supports palettes.
    If Not GetDeviceCaps(hdc, RASTERCAPS) And RC_PALETTE Then
        Beep
        MsgBox "This monitor does not support palettes.", _
            vbCritical
        End
    End If
    ' Get system palette size and # static colors.
    SysPalSize = GetDeviceCaps(hdc, SIZEPALETTE)
    NumStaticColors = GetDeviceCaps(hdc, NUMRESERVED)
    StaticColor1 = NumStaticColors \ 2 - 1
    StaticColor2 = SysPalSize - NumStaticColors \ 2
    ' Remove the borders from FromPict.
    FromPict.BorderStyle = vbTransparent
    ' Make sure FromPict has control.
    FromPict.ZOrder
End Sub
' ***********************************************
' Make the picture as large as possible.
' ***********************************************
Private Sub Form_Resize()
Const GAP = 4
Dim hgt As Single
Dim wid As Single
    If WindowState = vbMinimized Then Exit Sub

    hgt = ScaleHeight - FromHBar.Height - 1
    wid = ScaleWidth - FromVBar.Width - 1 - _
        GAP - HistPict.Width
    ' Place FromSwin and its scroll bars.
    FromSwin.Move 0, 0, wid, hgt
    FromVBar.Move _
        FromSwin.Left + FromSwin.Width + 1, _
        0, FromVBar.Width, hgt
    FromHBar.Move _
        FromSwin.Left, FromSwin.Height + 1, _
        wid
    ' Place HistPict.
    HistPict.Move FromVBar.Left + FromVBar.Width + GAP, 0
    ' Set the scroll bar limits.
    ResetScrollBars
End Sub
' ***********************************************
' Move FromPict within FromSwin.
' ***********************************************
Private Sub FromHBar_Change()
    FromPict.Left = -FromHBar.Value
End Sub
' ***********************************************
' Move FromPict within FromSwin.
' ***********************************************
Private Sub FromHBar_Scroll()
    FromPict.Left = -FromHBar.Value
End Sub
' ************************************************
' Set the binary contrast cutoff at this X value.
' ************************************************
Private Sub HistPict_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If X > 255 Then X = 256
    SetBinaryContrast FromPict, X - 1
    ShowHistogram
End Sub
' ***********************************************
' Load a new image file.
' ***********************************************
Private Sub mnuFileLoad_Click()
Dim fname As String
    ' Allow the user to pick a file.
    On Error Resume Next
    FileDialog.filename = "*.BMP;*.ICO;*.RLE;*.WMF;*.DIB"
    FileDialog.Flags = cdlOFNFileMustExist + cdlOFNHideReadOnly
    FileDialog.ShowOpen
    If Err.Number = cdlCancel Then
        Exit Sub
    ElseIf Err.Number <> 0 Then
        Beep
        MsgBox "Error selecting file.", , vbExclamation
        Exit Sub
    End If
    On Error GoTo 0
    fname = Trim$(FileDialog.filename)
    FileDialog.InitDir = Left$(fname, Len(fname) _
        - Len(FileDialog.FileTitle) - 1)
    ' Load the picture.
    WaitStart
    DoEvents
    LoadFromPict fname
    WaitEnd
End Sub
' ***********************************************
' End the application. (See also the QueryUnload
' event.)
' ***********************************************
Private Sub mnuFileExit_Click()
    Unload Me
End Sub
' ***********************************************
' Move FromPict within FromSwin.
' ***********************************************
Private Sub FromVBar_Change()
    FromPict.Top = -FromVBar.Value
End Sub
' ***********************************************
' Move FromPict within FromSwin.
' ***********************************************
Private Sub FromVBar_Scroll()
    FromPict.Top = -FromVBar.Value
End Sub